home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Controls / Visual Basic Controls.iso / vbcontrol / messag / mdimain.fr_ / mdimain.fr (.txt)
Encoding:
Visual Basic Form  |  1995-01-14  |  17.8 KB  |  477 lines
  1. VERSION 2.00
  2. Begin MDIForm MDImain 
  3.    Caption         =   "Message.VBX Demo"
  4.    ClientHeight    =   4950
  5.    ClientLeft      =   420
  6.    ClientTop       =   1770
  7.    ClientWidth     =   8760
  8.    Height          =   5640
  9.    Icon            =   MDIMAIN.FGX:0000
  10.    Left            =   360
  11.    LinkTopic       =   "MDIForm1"
  12.    Top             =   1140
  13.    Width           =   8880
  14.    Begin PictureBox PicStatus 
  15.       Align           =   2  'Align Bottom
  16.       BackColor       =   &H00C0C0C0&
  17.       BorderStyle     =   0  'None
  18.       Height          =   420
  19.       Left            =   0
  20.       ScaleHeight     =   420
  21.       ScaleWidth      =   8760
  22.       TabIndex        =   0
  23.       Top             =   4530
  24.       Width           =   8760
  25.       Begin Timer Timer1 
  26.          Interval        =   500
  27.          Left            =   3000
  28.          Top             =   0
  29.       End
  30.       Begin Message Message1 
  31.          Left            =   2520
  32.          Top             =   0
  33.       End
  34.       Begin Label LblSBcaps 
  35.          Alignment       =   2  'Center
  36.          BackStyle       =   0  'Transparent
  37.          Caption         =   "CAPS"
  38.          FontBold        =   0   'False
  39.          FontItalic      =   0   'False
  40.          FontName        =   "Arial"
  41.          FontSize        =   8.25
  42.          FontStrikethru  =   0   'False
  43.          FontUnderline   =   0   'False
  44.          Height          =   225
  45.          Left            =   7260
  46.          TabIndex        =   5
  47.          Top             =   100
  48.          Width           =   615
  49.       End
  50.       Begin Label LblSBnum 
  51.          Alignment       =   2  'Center
  52.          BackStyle       =   0  'Transparent
  53.          Caption         =   "NUM"
  54.          FontBold        =   0   'False
  55.          FontItalic      =   0   'False
  56.          FontName        =   "Arial"
  57.          FontSize        =   8.25
  58.          FontStrikethru  =   0   'False
  59.          FontUnderline   =   0   'False
  60.          Height          =   225
  61.          Left            =   7980
  62.          TabIndex        =   4
  63.          Top             =   100
  64.          Width           =   615
  65.       End
  66.       Begin Label LblSBdate 
  67.          Alignment       =   2  'Center
  68.          BackStyle       =   0  'Transparent
  69.          Caption         =   "12/25/96"
  70.          FontBold        =   0   'False
  71.          FontItalic      =   0   'False
  72.          FontName        =   "Arial"
  73.          FontSize        =   8.25
  74.          FontStrikethru  =   0   'False
  75.          FontUnderline   =   0   'False
  76.          Height          =   225
  77.          Left            =   4920
  78.          TabIndex        =   3
  79.          Top             =   100
  80.          Width           =   795
  81.       End
  82.       Begin Label LblSBtime 
  83.          Alignment       =   2  'Center
  84.          BackStyle       =   0  'Transparent
  85.          Caption         =   "00:00"
  86.          FontBold        =   0   'False
  87.          FontItalic      =   0   'False
  88.          FontName        =   "Arial"
  89.          FontSize        =   8.25
  90.          FontStrikethru  =   0   'False
  91.          FontUnderline   =   0   'False
  92.          Height          =   225
  93.          Left            =   4020
  94.          TabIndex        =   2
  95.          Top             =   105
  96.          Width           =   795
  97.       End
  98.       Begin Label LblStatus 
  99.          BackStyle       =   0  'Transparent
  100.          Caption         =   "Menu Status Goes Here..."
  101.          FontBold        =   0   'False
  102.          FontItalic      =   0   'False
  103.          FontName        =   "Arial"
  104.          FontSize        =   8.25
  105.          FontStrikethru  =   0   'False
  106.          FontUnderline   =   0   'False
  107.          Height          =   225
  108.          Left            =   120
  109.          TabIndex        =   1
  110.          Top             =   100
  111.          Width           =   3795
  112.       End
  113.    End
  114.    Begin Menu mnuDemos 
  115.       Caption         =   "&Demos"
  116.       Begin Menu mnuDemosMoveForm 
  117.          Caption         =   "Moving Captionless &Form..."
  118.       End
  119.       Begin Menu mnuDemosMoveControl 
  120.          Caption         =   "Moving &Controls..."
  121.       End
  122.       Begin Menu mnuDemosSep01 
  123.          Caption         =   "-"
  124.       End
  125.       Begin Menu mnuDemosExit 
  126.          Caption         =   "E&xit"
  127.       End
  128.    End
  129.    Begin Menu mnuHelp 
  130.       Caption         =   "&Help"
  131.       Begin Menu mnuHelpContents 
  132.          Caption         =   "VBX Help &Contents..."
  133.       End
  134.       Begin Menu mnuHelpSearch 
  135.          Caption         =   "VBX Help &Search..."
  136.       End
  137.       Begin Menu mnuHelpSep01 
  138.          Caption         =   "-"
  139.       End
  140.       Begin Menu mnuHelpAbout 
  141.          Caption         =   "&About..."
  142.       End
  143.       Begin Menu mnuHelpSep02 
  144.          Caption         =   "-"
  145.       End
  146.       Begin Menu mnuHelpCatalog 
  147.          Caption         =   "Catalog of &Products..."
  148.       End
  149.       Begin Menu mnuHelpReg 
  150.          Caption         =   "Online &Registration..."
  151.       End
  152.       Begin Menu mnuHelpOrder 
  153.          Caption         =   "&Order Form..."
  154.       End
  155.       Begin Menu mnuHelpEval 
  156.          Caption         =   "&Evaluation Form..."
  157.       End
  158.       Begin Menu mnuHelpShareware 
  159.          Caption         =   "Shareware &Information..."
  160.       End
  161.    End
  162. Sub DoPicChild3D (Obj As Control, Style, thick)
  163. 'draws 3D shadows effects around a control
  164. 'Style is either "sunken" or "raised"
  165. 'use this function in the Paint event of the form
  166.     If thick <= 0 Then thick = 1
  167.     If thick > 8 Then thick = 8
  168.     OldMode = Obj.Parent.PicStatus.ScaleMode
  169.     OldWidth = Obj.Parent.PicStatus.DrawWidth
  170.     Obj.Parent.PicStatus.ScaleMode = 3
  171.     Obj.Parent.PicStatus.DrawWidth = 1
  172.     ObjHeight = Obj.Height
  173.     ObjWidth = Obj.Width
  174.     ObjLeft = Obj.Left
  175.     ObjTop = Obj.Top
  176.     Select Case LCase$(Style)
  177.         Case "sunken":
  178.             TLshade = QBColor(8)
  179.             BRshade = QBColor(15)
  180.         Case "raised":
  181.             TLshade = QBColor(15)
  182.             BRshade = QBColor(8)
  183.         End Select
  184.         For i = 1 To thick
  185.             CurLeft = ObjLeft - i
  186.             CurTop = ObjTop - i
  187.             CurWide = ObjWidth + (i * 2) - 1
  188.             CurHigh = ObjHeight + (i * 2) - 1
  189.             Obj.Parent.PicStatus.Line (CurLeft, CurTop)-Step(CurWide, 0), TLshade
  190.             Obj.Parent.PicStatus.Line -Step(0, CurHigh), BRshade
  191.             Obj.Parent.PicStatus.Line -Step(-CurWide, 0), BRshade
  192.             Obj.Parent.PicStatus.Line -Step(0, -CurHigh), TLshade
  193.             Next i
  194.         If thick > 2 Then
  195.             CurLeft = ObjLeft - thick - 1
  196.             CurTop = ObjTop - thick - 1
  197.             CurWide = ObjWidth + ((thick + 1) * 2) - 1
  198.             CurHigh = ObjHeight + ((thick + 1) * 2) - 1
  199.             Obj.Parent.PicStatus.Line (CurLeft, CurTop)-Step(CurWide, 0), QBColor(0)
  200.             Obj.Parent.PicStatus.Line -Step(0, CurHigh), QBColor(0)
  201.             Obj.Parent.PicStatus.Line -Step(-CurWide, 0), QBColor(0)
  202.             Obj.Parent.PicStatus.Line -Step(0, -CurHigh), QBColor(0)
  203.             End If
  204.     Obj.Parent.PicStatus.ScaleMode = OldMode
  205.     Obj.Parent.PicStatus.DrawWidth = OldWidth
  206. End Sub
  207. Sub MDIForm_Load ()
  208.     Screen.MousePointer = 11
  209.     FormCenterScreen Me
  210.     initialize
  211.     LblStatus.Caption = ""
  212.     LblSBtime.Caption = ""
  213.     LblSBdate.Caption = ""
  214.     'define the hWnd for Message to Receive messages from
  215.     Message1.hWindow = Me.hWnd
  216.     'now define the various message we want to intercept
  217.     Message1.Status(WM_MenuSelect) = True       'for menu dragging messages
  218.     Message1.Status(WM_SysCommand) = True       'for custom sysmenu item responses and messages
  219.     Message1.Status(WM_GetMinMaxInfo) = True    'to set minimum and maximum form resize
  220.     'add a new system menu item
  221.     SysMenuAppendLine Me, 2000
  222.     SysMenuAppendMsg Me, "This is test #&1...", 2001
  223.     SysMenuAppendMsg Me, "This is test #&2...", 2002
  224.     SysMenuAppendMsg Me, "This is test #&3...", 2003
  225.     mnuhelp.Caption = Chr$(8) + mnuhelp.Caption
  226.     Timer1_Timer
  227.     FirstMsg.Show
  228.     Screen.MousePointer = 0
  229. End Sub
  230. Sub Message1_Receive (Msg As Integer, wParam As Integer, lParam As Long, UseRetVal As Integer, RetVal As Long)
  231.     If Msg = WM_MenuSelect Then 'menu message
  232.         If wParam < 0 Then
  233.             'system menu
  234.             Select Case wParam  'these are standard SysMenu wParam codes
  235.                 Case -3808: SBmsg$ = "Restore the demo window size"
  236.                 Case -4080: SBmsg$ = "Move the demo window"
  237.                 Case -4096: SBmsg$ = "Change the demo window size"
  238.                 Case -4064: SBmsg$ = "Minimize the demo to an icon"
  239.                 Case -4048: SBmsg$ = "Maximize the demo window"
  240.                 Case -4000: SBmsg$ = "Close the demo application"
  241.                 Case -3792: SBmsg$ = "Display the task list"
  242.                 End Select
  243.             LblStatus.Caption = " " + SBmsg$
  244.             Exit Sub
  245.             'no item selected
  246.             ElseIf wParam = 0 And lParam = 65535 Then
  247.                 LblStatus.Caption = ""
  248.                 Exit Sub
  249.             'respond to custom sysmenu dragging
  250.             ElseIf wParam = 2001 Then
  251.                 LblStatus.Caption = " This is test #1 in action"
  252.                 Exit Sub
  253.             ElseIf wParam = 2002 Then
  254.                 LblStatus.Caption = " This is test #2 in action"
  255.                 Exit Sub
  256.             ElseIf wParam = 2003 Then
  257.                 LblStatus.Caption = " This is test #3 in action"
  258.                 Exit Sub
  259.             Else
  260.             'normal menu items
  261.             hMenu% = GetMenu(Me.hWnd)
  262.             ReturnString$ = Space$(255)
  263.             ret% = GetMenuString(hMenu%, wParam, ReturnString$, 255, 0)
  264.             ReturnString$ = TrimAtNull(ReturnString$)
  265.             'remove any Shortcut key text
  266.             pos% = InStr(ReturnString$, Chr$(9))
  267.             If pos% <> 0 Then ReturnString$ = Left$(ReturnString$, pos% - 1)
  268.             'now ReturnString$=the actual menu item text (including any ampersands)
  269.             Select Case ReturnString$
  270.                 Case "Moving Captionless &Form...": SBmsg$ = "How to implement a moveable captionless form"
  271.                 Case "Moving &Controls...": SBmsg$ = "How to move controls at run-time"
  272.                 Case "E&xit": SBmsg$ = "End the Message.VBX demo"
  273.                 Case "VBX Help &Contents...": SBmsg$ = "Display contents page of Message.HLP"
  274.                 Case "VBX Help &Search...": SBmsg$ = "Start Message.HLP with a topical search"
  275.                 Case "&About...": SBmsg$ = "Copyright message window"
  276.                 Case "Catalog of &Products...": SBmsg$ = "Get our shareware catalog"
  277.                 Case "Online &Registration...": SBmsg$ = "Instructions for registering through CIS"
  278.                 Case "&Order Form...": SBmsg$ = "Get an Order Form for printing"
  279.                 Case "&Evaluation Form...": SBmsg$ = "Get our product Evaluation Form"
  280.                 Case "Shareware &Information...": SBmsg$ = "Get information on shareware"
  281.                 End Select
  282.             LblStatus.Caption = " " + SBmsg$
  283.             Exit Sub
  284.             End If
  285.     End If
  286.     If Msg = WM_GetMinMaxInfo Then 'set min/max window dimensions
  287.         Dim MinMax As MinMaxInfo
  288.         MessageDataGet lParam, Len(MinMax), MinMax
  289.             ScreenWide% = (Screen.Width / Screen.TwipsPerPixelX) - 20
  290.             ScreenHigh% = (Screen.Height / Screen.TwipsPerPixelY) - 20
  291.             MinMax.ptMaxSize.x = ScreenWide%    'when maximized
  292.             MinMax.ptMaxSize.y = ScreenHigh%    'when maximized
  293.             MinMax.ptMaxPosition.x = 10         'when maximized
  294.             MinMax.ptMaxPosition.y = 0          'when maximized
  295.             MinMax.ptMaxTrackSize.x = ScreenWide%   'when normal
  296.             MinMax.ptMaxTrackSize.y = ScreenHigh%   'when normal
  297.             MinMax.ptMinTrackSize.x = 496           'when normal
  298.             MinMax.ptMinTrackSize.y = 300           'when normal
  299.         MessageDataSet lParam, Len(MinMax), MinMax
  300.         UseRetVal = 1'use our own return value
  301.         RetVal = 0
  302.         End If
  303.     If Msg = WM_SysCommand Then 'system menu click
  304.         If wParam = 2001 Then
  305.             TheMsg$ = "This is test #1..." + nl + nl
  306.             TheMsg$ = TheMsg$ + "You can do anything here."
  307.             MsgBox TheMsg$, 48, "Custom System Menu Response"
  308.             End If
  309.         If wParam = 2002 Then
  310.             TheMsg$ = "This is test #2..." + nl + nl
  311.             TheMsg$ = TheMsg$ + "You can do anything here too." + nl + nl
  312.             TheMsg$ = TheMsg$ + "'This is test #1' is DISABLED!"
  313.             MsgBox TheMsg$, 48, "Custom System Menu Response"
  314.             SysMenuDisable Me, 2001
  315.             End If
  316.         If wParam = 2003 Then
  317.             TheMsg$ = "This is test #3..." + nl + nl
  318.             TheMsg$ = TheMsg$ + "You can do anything here as well." + nl + nl
  319.             TheMsg$ = TheMsg$ + "'This is test #1' is ENABLED!"
  320.             MsgBox TheMsg$, 48, "Custom System Menu Response"
  321.             SysMenuEnable Me, 2001
  322.             End If
  323.         End If
  324. End Sub
  325. Sub mnuDemos_Click ()
  326.     mnuDemosMoveControl.Enabled = True
  327.     If DisplayedMoveCtl = True Then
  328.         If MoveCtl.WindowState = 0 Then
  329.             mnuDemosMoveControl.Enabled = False
  330.             End If
  331.         End If
  332. End Sub
  333. Sub mnuDemosExit_Click ()
  334.     End
  335. End Sub
  336. Sub mnuDemosMoveControl_Click ()
  337.     If DisplayedMoveCtl = True Then
  338.         MoveCtl.SetFocus
  339.         MoveCtl.WindowState = 0
  340.         Else
  341.         Screen.MousePointer = 11
  342.         MoveCtl.Show
  343.         End If
  344. End Sub
  345. Sub mnuDemosMoveForm_Click ()
  346.     Screen.MousePointer = 11
  347.     FormMove.Show 1
  348. End Sub
  349. Sub mnuHelpAbout_Click ()
  350.     Screen.MousePointer = 11
  351.     About.Show 1
  352. End Sub
  353. Sub mnuHelpCatalog_Click ()
  354.         On Error Resume Next
  355.         WinPath$ = GetWinDir()
  356.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  357.         DocPath$ = App.Path
  358.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  359.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  360.             End If
  361.         DocPath$ = BackSlashAdd(DocPath$) + "DPCT0195.WRI"
  362.         FullPath$ = WinPath$ + " " + DocPath$
  363.         Screen.MousePointer = 11
  364.         x = Shell(FullPath$, 3)
  365.         Screen.MousePointer = 0
  366. End Sub
  367. Sub mnuHelpContents_Click ()
  368.     On Error Resume Next
  369.     MyHelpFile$ = App.Path
  370.     MyHelpFile$ = BackSlashAdd(MyHelpFile$) + "MESSAGE.HLP"
  371.     Screen.MousePointer = 11
  372.     ret% = WinHelp(Me.hWnd, MyHelpFile$, HELP_CONTENTS, 0&)
  373.     Screen.MousePointer = 0
  374. End Sub
  375. Sub mnuHelpEval_Click ()
  376.         On Error Resume Next
  377.         WinPath$ = GetWinDir()
  378.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  379.         DocPath$ = App.Path
  380.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  381.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  382.             End If
  383.         DocPath$ = BackSlashAdd(DocPath$) + "EVALFRM.WRI"
  384.         FullPath$ = WinPath$ + " " + DocPath$
  385.         Screen.MousePointer = 11
  386.         x = Shell(FullPath$, 3)
  387.         Screen.MousePointer = 0
  388. End Sub
  389. Sub mnuHelpOrder_Click ()
  390.         On Error Resume Next
  391.         WinPath$ = GetWinDir()
  392.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  393.         DocPath$ = App.Path
  394.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  395.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  396.             End If
  397.         DocPath$ = BackSlashAdd(DocPath$) + "ORDERFRM.WRI"
  398.         FullPath$ = WinPath$ + " " + DocPath$
  399.         Screen.MousePointer = 11
  400.         x = Shell(FullPath$, 3)
  401.         Screen.MousePointer = 0
  402. End Sub
  403. Sub mnuHelpReg_Click ()
  404.         On Error Resume Next
  405.         WinPath$ = GetWinDir()
  406.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  407.         DocPath$ = App.Path
  408.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  409.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  410.             End If
  411.         DocPath$ = BackSlashAdd(DocPath$) + "OnlineRg.WRI"
  412.         FullPath$ = WinPath$ + " " + DocPath$
  413.         Screen.MousePointer = 11
  414.         x = Shell(FullPath$, 3)
  415.         Screen.MousePointer = 0
  416. End Sub
  417. Sub mnuHelpSearch_Click ()
  418.     On Error Resume Next
  419.     MyHelpFile$ = App.Path
  420.     MyHelpFile$ = BackSlashAdd(MyHelpFile$) + "MESSAGE.HLP"
  421.     Screen.MousePointer = 11
  422.     ret% = WinHelp(Me.hWnd, MyHelpFile$, HELP_PARTIALKEY, "")
  423.     Screen.MousePointer = 0
  424. End Sub
  425. Sub mnuHelpShareware_Click ()
  426.         On Error Resume Next
  427.         WinPath$ = GetWinDir()
  428.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  429.         DocPath$ = App.Path
  430.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  431.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  432.             End If
  433.         DocPath$ = BackSlashAdd(DocPath$) + "SHARWARE.WRI"
  434.         FullPath$ = WinPath$ + " " + DocPath$
  435.         Screen.MousePointer = 11
  436.         x = Shell(FullPath$, 3)
  437.         Screen.MousePointer = 0
  438. End Sub
  439. Sub PicStatus_Paint ()
  440.     DoPicture3D PicStatus, "raised", 2, 0
  441.     DoPicChild3D LblStatus, "sunken", 1
  442.     DoPicChild3D LblSBtime, "sunken", 1
  443.     DoPicChild3D LblSBdate, "sunken", 1
  444.     DoPicChild3D LblSBnum, "sunken", 1
  445.     DoPicChild3D LblSBcaps, "sunken", 1
  446. End Sub
  447. Sub PicStatus_Resize ()
  448.     LblSBnum.Left = PicStatus.Width - 780
  449.     LblSBcaps.Left = LblSBnum.Left - 720
  450.     PicStatus.Cls
  451.     PicStatus_Paint
  452. End Sub
  453. Sub Timer1_Timer ()
  454.     'StatusBar Time
  455.     ThisTime$ = LCase$(Format$(Now, "medium time"))
  456.     If Left$(ThisTime$, 1) = "0" Then
  457.         ThisTime$ = Right$(ThisTime$, Len(ThisTime$) - 1)
  458.         End If
  459.     LblSBtime.Caption = ThisTime$
  460.     'StatusBar Date
  461.     ThisDate$ = Format$(Now, "medium date")
  462.     ThisDate$ = replace(ThisDate$, "-", " ")
  463.     LblSBdate.Caption = ThisDate$
  464.     'NumLock
  465.     If GetStateOfKey("NumLock") Then
  466.         LblSBnum.Caption = "NUM"
  467.         Else
  468.         LblSBnum.Caption = ""
  469.         End If
  470.     'CapsLock
  471.     If GetStateOfKey("CapsLock") Then
  472.         LblSBcaps.Caption = "CAPS"
  473.         Else
  474.         LblSBcaps.Caption = ""
  475.         End If
  476. End Sub
  477.